Amiga Tools 5/Amiga Tools 5.iso/tools/developer-tools/andere sprachen/oberonv4/oberon-src/system/locelems.mod

Oberon Text | 1996-02-12 | 16.7 KB | 412 lines

Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
StampElems
Alloc
12 Feb 96
Syntax10b.Scn.Fnt
FoldElems
MODULE LocElems;    (** SHML, 4 Jan 96,
, based on PopupElems **)
    (** Provide menu to locate positions in a text. As default, it searches for procedure headings.
        Other search procedures for specific file extensions can be installed. *)
    IMPORT
        Oberon, Input, Display, Viewers, Files, Fonts, Printer,
        Texts, TextFrames, MenuViewers, TextPrinter, Pictures, Amiga;
    CONST
        Ceres = FALSE;
        VersionTag = 0X;
        MenuDW = 3; MenuDH = 1;    (* margins of menu box *)
        DUnit = TextFrames.Unit; PUnit = TextPrinter.Unit;
        MR = 0; MM = 1; ML = 2; cancel = {ML, MM, MR};
        white = Display.white; black = Display.black;
        paint = Display.paint; replace = Display.replace; invert = Display.invert;
        StrLen*= 64;
        TableLen = 128;
    TYPE
        String = ARRAY StrLen OF CHAR;
        Entry = RECORD
            str: String;
            pos: LONGINT
        END;
        Table = ARRAY TableLen OF Entry;
        Elem*= POINTER TO ElemDesc;
        ElemDesc = RECORD (Texts.ElemDesc)
            name: ARRAY 32 OF CHAR;
            n, width: INTEGER;    (* number of items, width *)
            line: BOOLEAN;
            stampLen: LONGINT;
            t: Table
        END;
        SearchProc*= PROCEDURE(e: Elem; t: Texts.Text; VAR sort(*out*): BOOLEAN);
        Element = POINTER TO ElementDesc;
        ElementDesc = RECORD
            ext: ARRAY 32 OF CHAR; search: SearchProc;
            next: Element
        END;
    VAR wr: Texts.Writer; buf: Texts.Buffer; root: Element; defaultSearch: SearchProc; saveArea:Pictures.Picture;
    PROCEDURE Str(s: ARRAY OF CHAR);    BEGIN Texts.WriteString(wr, s) END Str;
    PROCEDURE Ln;    BEGIN Texts.WriteLn(wr) END Ln;
    (* non_portable stuff *)
    PROCEDURE Save(X, Y, W, H: INTEGER);    (* copy from screen X, Y, W, H into save area *)
    BEGIN
        Pictures.Create(saveArea,W,H,Amiga.Depth);
        Pictures.CopyBlock(Display.screen,saveArea,X,Y,W,H,0,0,replace)
    END Save;
    PROCEDURE Restore(X, Y, W, H: INTEGER);    (* restore from save area to screen X, Y, W, H *)
    BEGIN
        Pictures.CopyBlock(saveArea,Display.screen,0,0,W,H,X,Y,replace)
    END Restore;
    (* auxiliary *)
    PROCEDURE Min(x, y: INTEGER): INTEGER;    BEGIN IF x < y THEN RETURN x ELSE RETURN y END END Min;
    PROCEDURE Max(x, y: INTEGER): INTEGER;    BEGIN IF x > y THEN RETURN x ELSE RETURN y END END Max;
    PROCEDURE StrDispWidth(fnt: Fonts.Font; s: ARRAY OF CHAR): LONGINT;
        VAR pat: Display.Pattern; width, i, dx, x, y, w, h: INTEGER;
    BEGIN
        width := 0; i := 0;
        WHILE s[i] # 0X DO Display.GetChar(fnt.raster, s[i], dx, x, y, w, h, pat); INC(width, dx); INC(i) END;
        RETURN LONG(width)*DUnit
    END StrDispWidth;
    PROCEDURE DispStr(fnt: Fonts.Font; s: ARRAY OF CHAR; col, x0, y0: INTEGER);
        VAR pat: Display.Pattern; i, dx, x, y, w, h: INTEGER;
    BEGIN
        i := 0;
        WHILE s[i] # 0X DO
            Display.GetChar(fnt.raster, s[i], dx, x, y, w, h, pat);
            Display.CopyPattern(col, pat, x0+x, y0+y, paint);
            INC(i); INC(x0, dx)
        END
    END DispStr;
    (* change propagation *)
    PROCEDURE PrepareDraw(e: Elem; fnt: Fonts.Font; VAR dy: INTEGER);
        VAR width, dh: INTEGER;
    BEGIN
        width := 0; dh := 0; dy := fnt.minY;
        IF dy > -2 THEN dy := -2 END;
        e.W := LONG(width)*DUnit+StrDispWidth(fnt, e.name)+DUnit; e.H := LONG(fnt.maxY-fnt.minY+dh)*DUnit
    END PrepareDraw;
    PROCEDURE Sort(e: Elem);
        (* sort the array with insertion sort (because it's stable!) *)
        VAR i, j: INTEGER; entry: Entry;
    BEGIN
        FOR j := 1 TO e.n-1 DO
            entry := e.t[j];
            i := j-1;
            WHILE (i >= 0) & (entry.str < e.t[i].str) DO e.t[i+1] := e.t[i]; DEC(i) END;
            e.t[i+1] := entry
        END
    END Sort;
    PROCEDURE Append*(e: Elem; str: ARRAY OF CHAR; pos: LONGINT): BOOLEAN;
        (** append str and pos to table in element e, return "table is full"; (LEN(str) <= StrLen, 100) *)
    BEGIN
        ASSERT(LEN(str) <= StrLen, 100);
        IF e.n < TableLen THEN COPY(str, e.t[e.n].str); e.t[e.n].pos := pos; INC(e.n) END;
        RETURN e.n = TableLen
    END Append;
    PROCEDURE DefaultSearch(e: Elem; t: Texts.Text; VAR sort(*out*): BOOLEAN);
        VAR s: Texts.Scanner; str, type: ARRAY 32 OF CHAR; class, i, j: INTEGER;
    BEGIN
        Texts.OpenScanner(s, t, 0);
        LOOP
            WHILE ~s.eot & ((s.class # Texts.Name) OR (s.s # "PROCEDURE")) DO Texts.Scan(s) END;
            IF s.eot THEN EXIT END;
            (* s.s = PROCEDURE *)
            type := "";
            Texts.Scan(s);
            IF ~((s.class = Texts.Char) & (s.c = "^")) THEN    (* ignore forward declarations *)
                IF s.class = Texts.Char THEN    (* ( *)
                    IF s.c = "(" THEN
                        REPEAT COPY(s.s, type); class := s.class; Texts.Scan(s)
                        UNTIL s.eot OR (class = Texts.Name) & (s.class = Texts.Char) & (s.c = ")");
                        IF s.eot THEN EXIT END
                    END;
                    Texts.Scan(s)
                END;
                IF s.class = Texts.Name THEN
                    i := -1;
                    IF type # "" THEN
                        REPEAT INC(i); str[i] := type[i] UNTIL str[i] = 0X;
                        str[i] := "."
                    END;
                    j := -1;
                    REPEAT INC(j); INC(i); str[i] := s.s[j] UNTIL str[i] = 0X;
                    IF Append(e, str, Texts.Pos(s)-1) THEN EXIT END
                END
            END
        END;
        sort := TRUE
    END DefaultSearch;
    PROCEDURE Extension(name: ARRAY OF CHAR; VAR ext: ARRAY OF CHAR);
        VAR i, j: INTEGER;
    BEGIN
        i := -1; REPEAT INC(i) UNTIL name[i] = 0X;
        REPEAT DEC(i) UNTIL (name[i] = ".") OR (i = 0);
        IF i = 0 THEN ext[0] := 0X
        ELSE
            j := -1; REPEAT INC(i); INC(j); ext[j] := name[i] UNTIL (name[i] = 0X) OR (name[i] = '"');
            ext[j] := 0X
        END
    END Extension;
    PROCEDURE Search(ext: ARRAY OF CHAR; VAR prev: Element): Element;
        VAR l: Element;
    BEGIN
        l := root; prev := NIL;
        WHILE (l # NIL) & (l.ext # ext) DO prev := l; l := l.next END;
        RETURN l
    END Search;
    PROCEDURE Refresh(e: Elem; t: Texts.Text; menuFrame: Display.Frame);    (* generate menu text from t *)
        VAR
            s: Texts.Scanner; ext: ARRAY 32 OF CHAR; this, prev: Element;
            i, j, width, n, dx, x, y, w, h: INTEGER; p: LONGINT; sort: BOOLEAN;
    BEGIN
        IF t # NIL THEN
            e.n := 0; e.stampLen := t.len; sort := FALSE;
            WITH menuFrame: TextFrames.Frame DO
                Texts.OpenScanner(s, menuFrame.text, 0); Texts.Scan(s);
                IF s.class IN {Texts.Name, Texts.String} THEN
                    Extension(s.s, ext); this := Search(ext, prev);
                    IF this # NIL THEN this.search(e, t, sort) ELSE defaultSearch(e, t, sort) END
                ELSE defaultSearch(e, t, sort)
                END
            ELSE defaultSearch(e, t, sort)
            END;
            IF e.n > 0 THEN
                IF sort THEN Sort(e) END
            ELSE e.t[0].str := "no items in text"; e.t[0].pos := -1; e.n := 1
            END;
            n := e.n;
            WHILE n*Fonts.Default.height + 2*MenuDH + 4 > Oberon.DisplayHeight(0) DO DEC(n) END;
            IF n < e.n THEN
                e.n := n;
                Str("too many procedures, not all will be shown!"); Ln;
                Texts.Append(Oberon.Log, wr.buf)
            END;
            e.width := 0;
            FOR i := 0 TO n-1 DO
                j := 0; width := 0;
                WHILE e.t[i].str[j] # 0X DO
                    Display.GetChar(Fonts.Default.raster, e.t[i].str[j], dx, x, y, w, h, p); INC(width, dx);
                    INC(j)
                END;
                e.width := Max(e.width, width)
            END
        ELSE e.n := 0
        END
    END Refresh;
    (* file input/output *)
    PROCEDURE Load(VAR r: Files.Rider; e: Elem);
        VAR ch: CHAR;
    BEGIN
        Files.Read(r, ch);
        IF ch = VersionTag THEN Files.ReadString(r, e.name); Files.ReadBool(r, e.line) END
    END Load;
    PROCEDURE Store(VAR r: Files.Rider; e: Elem);
    BEGIN Files.Write(r, VersionTag); Files.WriteString(r, e.name); Files.WriteBool(r, e.line)
    END Store;
    (* graphics *)
    PROCEDURE Box(col, bkgnd, X, Y, W, H: INTEGER);
    BEGIN
        Display.ReplConst(col, X+1, Y+1, W-2, 1, replace);
        Display.ReplConst(col, X+1, Y+H-2, W-2, 1, replace);
        Display.ReplConst(col, X+1, Y+2, 1, H-4, replace);
        Display.ReplConst(col, X+W-2, Y+2, 1, H-4, replace);
        Display.ReplConst(col, X+4, Y, W-4, 1, replace);
        Display.ReplConst(col, X+W-1, Y+1, 1, H-4, replace);
        Display.ReplConst(bkgnd, X+2, Y+2, W-4, H-4, replace)
    END Box;
    PROCEDURE DrawElem(e: Elem; f: Display.Frame; pos: LONGINT; fnt: Fonts.Font; col, X, Y: INTEGER);
        VAR beg: LONGINT; parc: TextFrames.Parc; bkgndCol: INTEGER;
    BEGIN
        IF f IS TextFrames.Frame THEN bkgndCol := f(TextFrames.Frame).col ELSE bkgndCol := black END;
        TextFrames.ParcBefore(Texts.ElemBase(e), pos, parc, beg);
        INC(Y, SHORT(parc.dsr DIV DUnit));
        IF bkgndCol = col THEN col := ABS(white-col) END;
        DispStr(fnt, e.name, col, X, Y);
        IF e.line THEN Display.ReplPatternC(f, white, Display.grey1, X, Y-2, SHORT(e.W DIV DUnit), 1, X, Y-1, invert) END
    END DrawElem;
    PROCEDURE PrintElem(e: Elem; fnt: Fonts.Font; X, Y: INTEGER);
    BEGIN
        Printer.String(X, Y, e.name, fnt.name);
        IF e.line THEN Printer.ReplConst(X, Y-2, SHORT((e.W-1) DIV PUnit), 1) END
    END PrintElem;
    PROCEDURE DrawMenu(e: Elem; X, Y, W, H: INTEGER);
        VAR X0, dx, x, y, w, h, i, j: INTEGER; p: LONGINT;
    BEGIN
        Box(white, black, X, Y, W, H);
        X0 := X+MenuDW+2; Y := Y+H-Fonts.Default.height-Fonts.Default.minY-MenuDH-2;
        FOR i := 0 TO e.n-1 DO
            j := 0; X := X0;
            WHILE e.t[i].str[j] # 0X DO
                Display.GetChar(Fonts.Default.raster, e.t[i].str[j], dx, x, y, w, h, p);
                Display.CopyPattern(Display.white, p, X+x, Y+y, paint); INC(X, dx);
                INC(j)
            END;
            DEC(Y, Fonts.Default.height)
        END
    END DrawMenu;
    (* actions *)
    PROCEDURE Show(e: Elem; X, Y: INTEGER; VAR cmd: INTEGER; VAR keySum: SET);
        VAR
            eH, W, H, w, newY, mx, my, top, bot, left, right, newCmd: INTEGER;
            keys: SET;
        PROCEDURE Flip(cmd: INTEGER);
        BEGIN
            IF cmd >= 0 THEN
                Display.ReplConst(white, left, top-(cmd+1)*Fonts.Default.height, right-left, Fonts.Default.height, invert)
            END
        END Flip;
    BEGIN
        eH := SHORT(e.H DIV DUnit);
        Input.Mouse(keys, mx, my);
        W := e.width + 2*MenuDW + 4; H := e.n*Fonts.Default.height + 2*MenuDH + 4;
        IF (e.n = 0) OR (W > Oberon.DisplayWidth(X)) OR (H > Oberon.DisplayHeight(X)) THEN
            IF e.n > 0 THEN Str("LocElem too big!"); Ln; Texts.Append(Oberon.Log, wr.buf) END;
            REPEAT Input.Mouse(keys, mx, my); Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, mx, my)
            UNTIL keys = {};
            keySum := cancel; cmd := -1
        ELSE
            w := Oberon.DisplayWidth(X); left := Display.Left;
            IF Ceres & (X >= Display.Left+Display.Width) THEN    (* adjust if on secondary *)
                INC(w, Display.Width); left := Display.Left+Display.Width
            END;
            X := Min(w-W, Max(mx-W DIV 2, left));    (* X >= left & X+W <= w *)
            newY := my-((e.n-cmd)*Fonts.Default.height-Fonts.Default.height DIV 2);
            IF (newY >= Display.Bottom) & (newY+H <= Oberon.DisplayHeight(X)) THEN    (* popup at mouse pos *)
                Y := newY
            ELSE    (* drop down *)
                IF Y-H > Display.Bottom THEN Y := Y-H ELSE Y := Y+eH END;
                IF Y+H > Oberon.DisplayHeight(X) THEN Y := Display.Bottom END
            END;
            left := X+3; right := X+W-3; bot := Y+MenuDH+3; top := Y+H-MenuDH-2;
            Oberon.RemoveMarks(X, Y, W, H); Oberon.FadeCursor(Oberon.Mouse);
            Save(X, Y, W, H);    (* save background *)
            DrawMenu(e, X, Y, W, H);
            Flip(cmd); keySum := {};
            REPEAT
                Input.Mouse(keys, mx, my); keySum := keySum+keys;
                Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, mx, my);
                IF keySum = cancel THEN cmd := -1
                ELSIF (mx >= left) & (mx <= right) & (my >= bot) & (my <= top) THEN
                    newCmd := (top-my) DIV Fonts.Default.height;
                    IF newCmd # cmd THEN Flip(cmd); Flip(newCmd); cmd := newCmd END
                ELSE Flip(cmd); cmd := -1
                END
            UNTIL keys = {};
            Oberon.FadeCursor(Oberon.Mouse);
            Restore(X, Y, W, H)    (* restore background *)
        END
    END Show;
    PROCEDURE Popup(e: Elem; msg: TextFrames.TrackMsg);
        VAR
            v: Viewers.Viewer; tf: TextFrames.Frame;
            cmd: INTEGER; keys: SET;
            beg, end: LONGINT;
    BEGIN
        v := Viewers.This(msg.frame.X, msg.frame.Y);
        IF (v IS MenuViewers.Viewer) & (v.dsc = msg.frame) & (v.dsc.next IS TextFrames.Frame) THEN
            tf := v.dsc.next(TextFrames.Frame);
            IF tf.text.len # e.stampLen THEN Refresh(e, tf.text, msg.frame) END;
            keys := msg.keys; cmd := 0;
            Show(e, msg.X0, msg.Y0, cmd, keys);
            IF keys = {MM, MR} THEN Refresh(e, tf.text, msg.frame)
            ELSIF (keys # cancel) & (cmd > -1) & (e.t[cmd].pos >= 0) THEN
                beg := tf.org; end := TextFrames.Pos(tf, tf.X+tf.W, tf.Y);
                IF (e.t[cmd].pos < beg) OR (end <= e.t[cmd].pos) THEN TextFrames.Show(tf, e.t[cmd].pos) END;
                Oberon.PassFocus(v);
                TextFrames.SetCaret(tf, e.t[cmd].pos)
            END
        ELSE Str("LocElem not in menu viewer or content frame is not TextFrame"); Ln; Texts.Append(Oberon.Log, wr.buf)
        END
    END Popup;
    (* element *)
    PROCEDURE Handle(e: Texts.Elem; VAR msg: Texts.ElemMsg);
        VAR copy: Elem;
    BEGIN
        WITH e: Elem DO
            IF msg IS TextFrames.DisplayMsg THEN
                WITH msg: TextFrames.DisplayMsg DO
                    IF msg.prepare THEN PrepareDraw(e, msg.fnt, msg.Y0)
                    ELSE DrawElem(e, msg.frame, msg.pos, msg.fnt, msg.col, msg.X0, msg.Y0)
                    END
                END
            ELSIF msg IS TextPrinter.PrintMsg THEN
                WITH msg: TextPrinter.PrintMsg DO
                    IF ~msg.prepare THEN PrintElem(e, msg.fnt, msg.X0, msg.Y0) END
                END
            ELSIF msg IS Texts.CopyMsg THEN
                WITH msg: Texts.CopyMsg DO
                    NEW(copy); Texts.CopyElem(e, copy);
                    copy.name := e.name; copy.line := e.line;
                    msg.e := copy
                END
            ELSIF msg IS Texts.IdentifyMsg THEN
                WITH msg: Texts.IdentifyMsg DO
                    msg.mod := "LocElems"; msg.proc := "Alloc"
                END
            ELSIF msg IS Texts.FileMsg THEN
                WITH msg: Texts.FileMsg DO
                    IF msg.id = Texts.load THEN Load(msg.r, e)
                    ELSIF msg.id = Texts.store THEN Store(msg.r, e)
                    END
                END
            ELSIF msg IS TextFrames.TrackMsg THEN
                WITH msg: TextFrames.TrackMsg DO Popup(e, msg) END
            END
        END
    END Handle;
    PROCEDURE Alloc*;
        VAR e: Elem;
    BEGIN NEW(e); e.handle := Handle; Texts.new := e
    END Alloc;
    (** commands **)
    PROCEDURE Insert*;
        VAR e: Elem; ins: TextFrames.InsertElemMsg; s: Texts.Scanner;
    BEGIN
        NEW(e); e.line := TRUE;
        Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
        IF ~(s.class IN {Texts.Name, Texts.String}) OR (s.s[0] = 0X) THEN e.name := "Loc" ELSE COPY(s.s, e.name) END;
        e.handle := Handle; ins.e := e; Viewers.Broadcast(ins)
     END Insert;
    PROCEDURE Rename*;
        VAR e: Elem; text: Texts.Text; beg, end, time: LONGINT; r: Texts.Reader; s: Texts.Scanner;
    BEGIN
        Oberon.GetSelection(text, beg, end, time);
        IF time >= 0 THEN
            Texts.OpenReader(r, text, beg); Texts.ReadElem(r);
            IF (r.elem # NIL) & (r.elem IS Elem) THEN
                e := r.elem(Elem);
                Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
                IF s.class = Texts.Name THEN
                    COPY(s.s, e.name); text.notify(text, Texts.replace, Texts.ElemPos(e), Texts.ElemPos(e)+1)
                END
            END
        END
     END Rename;
     PROCEDURE Toggle*;
         VAR e: Elem; text: Texts.Text; beg, end, time: LONGINT; r: Texts.Reader;
    BEGIN
         Oberon.GetSelection(text, beg, end, time);
        IF time >= 0 THEN
            Texts.OpenReader(r, text, beg); Texts.ReadElem(r);
            IF (r.elem # NIL) & (r.elem IS Elem) THEN
                e := r.elem(Elem); e.line := ~e.line; text.notify(text, Texts.replace, Texts.ElemPos(e), Texts.ElemPos(e)+1)
            END
        END
     END Toggle;
    PROCEDURE Install*(ext: ARRAY OF CHAR; search: SearchProc);
        VAR new, this, prev: Element;
    BEGIN
        IF ext = "*" THEN defaultSearch := search
        ELSE
            NEW(new); COPY(ext, new.ext); new.search := search;
            this := Search(new.ext, prev);    (* check for duplicates *)
            IF this = NIL THEN new.next := root; root := new    (* new entry *)
            ELSIF this.search # new.search THEN    (* new entry for existing extension -> remove this *)
                IF this = root THEN new.next := root.next; root := new
                ELSE new.next := this.next; prev.next := new
                END
            END
        END
    END Install;
BEGIN NEW(buf); Texts.OpenBuf(buf); Texts.OpenWriter(wr); root := NIL; defaultSearch := DefaultSearch; NEW(saveArea)
END LocElems.